;;; Guile-GCC --- Guile extension to GCC.               -*- coding: utf-8 -*-
;;; Copyright (C) 2012 Ludovic Courtès
;;;
;;; This file is part of Guile-GCC.
;;;
;;; Guile-GCC is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; Guile-GCC is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with Guile-GCC.  If not, see <http://www.gnu.org/licenses/>.

(define-module (gcc cgraph)
  #:use-module (system foreign)
  #:use-module (ice-9 format)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module ((gcc) #:select (decl-name identifier-string))
  #:export (cgraph-node?
            cgraph-nodes
            cgraph-get-node
            cgraph-node-decl
            cgraph-node-callers
            cgraph-node-callees
            cgraph-node-analyzed?
            cgraph-edge?
            cgraph-edge-callee
            cgraph-edge-caller
            cgraph-edge-call-statement
            cgraph-nodes->dot))

;; Load the cgraph bindings.
(eval-when (eval load compile)
  (dynamic-call "ggcc_init_cgraph" (dynamic-link)))

(define-syntax-rule (cc1-symbol name)             ; FIXME: Deduplicate.
  "Return a `cc1' symbol, taken from the current DSO."
  (dynamic-func name (dynamic-link)))


;;;
;;; Nodes & edges.
;;;

(define-wrapped-pointer-type <cgraph-node> cgraph-node?
  wrap-cgraph-node unwrap-cgraph-node
  (lambda (n p)
    (format p "#<gcc cgraph-node ~x (~x)>"
            (object-address n)
            (object-address (unwrap-cgraph-node n)))))

(define-wrapped-pointer-type <cgraph-edge> cgraph-edge?
  wrap-cgraph-edge unwrap-cgraph-edge
  (lambda (n p)
    (format p "#<gcc cgraph-edge ~x (~x)>"
            (object-address n)
            (object-address (unwrap-cgraph-edge n)))))

(define (wrap-edge-list edge next)
  "Wrap the list rooted at EDGE and chained by the NEXT procedure."
  (unfold null-pointer?
          wrap-cgraph-edge
          next
          edge))

(define (false-or-wrap-node pointer)
  (if (null-pointer? pointer)
      #f
      (wrap-cgraph-node pointer)))

(define cgraph-get-node
  (let ((f (pointer->procedure '* (cc1-symbol "cgraph_get_node") '(*))))
    (lambda (tree)
      "Return the cgraph node of TREE or #f if it's not available yet."
      (let ((p (f ((@@ (gcc) %unwrap-tree) tree))))
        (if (null-pointer? p)
            #f
            (wrap-cgraph-node p))))))

(define cgraph-nodes
  (let ((p (cc1-symbol "cgraph_nodes")))
    (lambda ()
      "Return the list of analyzed cgraph nodes."
      (unfold null-pointer?
              wrap-cgraph-node
              (lambda (ptr)
                (let loop ((ptr (%cgraph-node-next ptr)))
                  (if (null-pointer? ptr)
                      ptr
                      (if (%cgraph-node-analyzed ptr)
                          ptr
                          (loop (%cgraph-node-next ptr))))))
              (dereference-pointer p)))))

(define-syntax-rule (define-cgraph-node-accessor name subr wrap-result)
  (define (name node)
    (wrap-result
     (subr (unwrap-cgraph-node node)))))

(define-cgraph-node-accessor cgraph-node-decl %cgraph-node-decl
  (@@ (gcc) false-or-wrap-tree))
(define-cgraph-node-accessor cgraph-node-callers %cgraph-node-callers
  (cut wrap-edge-list <> %cgraph-edge-next_caller))
(define-cgraph-node-accessor cgraph-node-callees %cgraph-node-callees
  (cut wrap-edge-list <> %cgraph-edge-next_callee))
(define-cgraph-node-accessor cgraph-node-analyzed? %cgraph-node-analyzed
  identity)


(define-syntax-rule (define-cgraph-edge-accessor name subr wrap-result)
  (define (name node)
    (wrap-result
     (subr (unwrap-cgraph-edge node)))))

(define-cgraph-edge-accessor cgraph-edge-callee %cgraph-edge-callee
  false-or-wrap-node)
(define-cgraph-edge-accessor cgraph-edge-caller %cgraph-edge-caller
  false-or-wrap-node)
(define-cgraph-edge-accessor cgraph-edge-call-statement
  %cgraph-edge-call_stmt
  (@@ (gcc gimple) %wrap-gimple))


;;;
;;; Dot/GraphViz output.
;;;

(define* (cgraph-nodes->dot nodes port
                            #:key (graph-name "Guile-GCC Call Graph"))
  "Write to PORT the `dot'-formatted graph rooted at NODES."
  (format port "digraph \"~a\" {~%" graph-name)
  (for-each (lambda (n)
              (define s
                (identifier-string (decl-name (cgraph-node-decl n))))

              (format port "  \"~a\";~%" s)

              (let ((c (delete-duplicates
                        (map (compose identifier-string decl-name
                                      cgraph-node-decl
                                      cgraph-edge-callee)
                             (cgraph-node-callees n)))))
                (for-each (cut format port "  \"~a\" -> \"~a\";~%" s <>) c)))
            nodes)
  (format port "}~%"))
